home *** CD-ROM | disk | FTP | other *** search
/ FM Towns: Free Software Collection 7 / FM Towns Free Software Collection 7.iso / data / happypas / bio.pas next >
Pascal/Delphi Source File  |  1993-11-30  |  8KB  |  218 lines
  1. {*********************************************************************
  2.  *  *** バイオリズム ***                                             *
  3.  *                                                                   *
  4.  *        HAPPyのサンプルプログラム                                  *
  5.  *          (作者  浅野比富美 Public Domain Software)                *
  6.  *********************************************************************}
  7.  
  8. program Biorhythm(input,output) ;
  9.  
  10.   type  kanji    = packed array[1..2] of char ;   { 全角1文字(漢字)  }
  11.  
  12.   var   Nissu    : array[1..12] of 1..31      ;   { 月の日数を格納   }
  13.         yb,mb,db : integer                    ;   { 生まれた年､月,日 }
  14.         yp,mp    : integer                    ;   { 出力したい年､月  }
  15.         Ychar    : kanji                      ;   { 漢字の曜日       }
  16.  
  17. {*****************************************
  18.  *      初期設定 (各月の日数を設定)      *
  19.  *        とりあえず 2月は28日としておく *
  20.  *****************************************}
  21.   procedure Init ;
  22.   begin
  23.     Nissu[ 1] := 31 ; Nissu[ 2] := 28 ; Nissu[ 3] := 31 ;
  24.     Nissu[ 4] := 30 ; Nissu[ 5] := 31 ; Nissu[ 6] := 30 ;
  25.     Nissu[ 7] := 31 ; Nissu[ 8] := 31 ; Nissu[ 9] := 30 ;
  26.     Nissu[10] := 31 ; Nissu[11] := 30 ; Nissu[12] := 31
  27.   end {Init} ;
  28.  
  29. {***************************************
  30.  *   y年m月d日の曜日を算出する         *
  31.  ***************************************}
  32.   procedure Youbi(y{年},m{月},d{日}:integer; var Ychar:kanji) ;
  33.     var m1,y1 : integer;
  34.   begin
  35.     if m >= 3 then  begin  m1 := m -  2 ; y1 := y     end
  36.               else  begin  m1 := m + 10 ; y1 := y - 1 end ;
  37.     case (y1 + y1 div 4 - y1 div 100 + y1 div 400
  38.                  + trunc(2.6*m1 -  0.19) + d) mod 7  of
  39.       0 : Ychar := '日' ;
  40.       1 : Ychar := '月' ;
  41.       2 : Ychar := '火' ;
  42.       3 : Ychar := '水' ;
  43.       4 : Ychar := '木' ;
  44.       5 : Ychar := '金' ;
  45.       6 : Ychar := '土'
  46.     end
  47.   end {Youbi} ;
  48.  
  49. {*****************************************
  50.  *   year年が閏年の時､真を返す関数       *
  51.  *     4年に一度だが､、100年に一度閏年で *
  52.  *     なく、400年に一度閏年になります   *
  53.  *****************************************}
  54.   function Uruu(year:integer) : Boolean ;
  55.   begin
  56.     Uruu := (year mod 4 = 0) and (year mod 100 <> 0) or (year mod 400 = 0)
  57.   end {Uruu} ;
  58.  
  59. {*******************************
  60.  *     閏年の2月日数補正       *
  61.  *******************************}
  62.   procedure UruuFeb(year : integer) ;
  63.   begin
  64.     if Uruu(year) then Nissu[2{月}] := 29{日}
  65.                   else Nissu[2{月}] := 28{日}
  66.   end {UruuFeb} ;
  67.  
  68. {*******************************
  69.  *          入力処理           *
  70.  *******************************}
  71.   procedure InputInformation ;
  72.     var Gengo      : char    ;     { 元号 m / t / s / h     }
  73.         UnderMonth : 1..12   ;     { 入力可能な出力月の下限 }
  74.         ok         : Boolean ;     { 入力チェック用フラグ   }
  75.   begin
  76.     writeln('***** 誕生日を教えて下さい *****');
  77.     repeat
  78.       write('  明治･･･m  大正･･･t  昭和･･･s  平成･･･h  ? ') ;
  79.       readln(Gengo{元号})
  80.     until (Gengo='m') or (Gengo='t') or (Gengo='s') or (Gengo='h') ;
  81.                  { 集合の元の順序数に制約がなければ
  82.                    until Gengo in ['m','t','s','h']  と するのが良い }
  83.  
  84.     repeat
  85.       write(' 何年 ? ') ;
  86.       readln(yb) ;
  87.       case Gengo of                { 範囲チェック & 西暦変換 }
  88.         'm' : begin ok:=(1<=yb) and (yb<={明治}45{年}) ; yb:=yb+1867 end ;
  89.         't' : begin ok:=(1<=yb) and (yb<={大正}15{年}) ; yb:=yb+1911 end ;
  90.         's' : begin ok:=(1<=yb) and (yb<={昭和}64{年}) ; yb:=yb+1925 end ;
  91.         'h' : begin ok:=(1<=yb) and (yb<={平成}50{年}) ; yb:=yb+1988 end
  92.                                             {   ↑ 平成は仮の値です　}
  93.       end
  94.     until ok ;
  95.  
  96.     repeat
  97.       write(' 何月 ? ') ;
  98.       readln(mb)
  99.     until (1{月}<=mb) and (mb<=12{月}) ;
  100.  
  101.     UruuFeb(yb) ;                  { 誕生年の2月の日数補正 }
  102.     repeat
  103.       write(' 何日 ? ') ;
  104.       readln(db)
  105.     until (1{日}<=db) and (db<=Nissu[mb]) ;
  106.  
  107.     writeln('***** バイオリズムを出したい年、月を教えて下さい *****');
  108.  
  109.     repeat
  110.       write(' 何年(西暦',yb:4,'～9999) ? ') ;   { 9999年に意味はない }
  111.       readln(yp)
  112.     until (yb<=yp) and (yp<=9999{年}) ;
  113.  
  114.     if yb=yp then UnderMonth := mb      { 誕生年と出力年が同じならば }
  115.              else UnderMonth := 1{月} ; { 出力月は、誕生月以降である }
  116.     repeat
  117.       write(' 何月(',UnderMonth:2,'～',12:2,') ? ') ;
  118.       readln(mp)
  119.     until (UnderMonth<=mp) and (mp<=12{月})
  120.  
  121.   end {InputInformation} ;
  122.  
  123. {*******************************
  124.  *       生存日数算出          *
  125.  *******************************}
  126.   function LivingDay : integer ;
  127.     var year,month : integer ;          { for文の制御変数 }
  128.         day        : integer ;          { 生存日          }
  129.   begin
  130.     day := 0 ;
  131.     for year := yb to yp-1 do           { 誕生年～出力年前年の日数算出}
  132.       if Uruu(year) then day := day + 366{日}     { 閏年は366日加える }
  133.                     else day := day + 365{日} ;   { 平年は365日       }
  134.     UruuFeb(yb) ;                             { 誕生年の2月の日数補正 }
  135.     for month := 1 to mb-1 do                 { 誕生年の日数を補正    }
  136.       day := day - Nissu[month] ;
  137.     day := day - db + 1 ;                     { 誕生月の日数を補正    }
  138.     UruuFeb(yp) ;                             { 出力年の2月の日数補正 }
  139.     for month := 1 to mp-1 do                 { 出力年の日数を加える  }
  140.       day := day + Nissu[month] ;
  141.  
  142.     LivingDay := day                          { 関数の戻り値(生存日)  }
  143.   end {LivingDay} ;
  144.  
  145. {*******************************
  146.  *     グラフ作成&出力処理     *
  147.  *******************************}
  148.   procedure Graph ;
  149.     const pai    = 3.141593    ;                   { 円周率          }
  150.           Vmax   = 8           ;                   { 縦軸方向の振幅値}
  151.           Hbias  = 6           ;                   { 横方向のバイアス}
  152.     type  xRange =     1..31   ;                   { 横軸範囲 日数分 }
  153.           yRange = -Vmax..Vmax ;                   { 縦軸範囲        }
  154.     var   point  : array[xRange,yRange] of kanji ; { グラフ座標      }
  155.           x      : xRange  ;                       { for文の制御変数 }
  156.           y      : yRange  ;                       { for文の制御変数 }
  157.           day    : integer ;                       { 生存日数        }
  158.           pai2   : real    ;                       { 2*円周率 (1円周ラジアン) }
  159.   begin
  160.     day := LivingDay ;              { 1日までの生存日数算出 }
  161.  
  162.     for x:=1 to 31 do               { グラフエリアの初期設定 }
  163.       for y:=-Vmax to Vmax do
  164.         point[x,y] := '　' ;
  165.     for x:=1 to 31 do
  166.     begin
  167.       point[x, Vmax] := '－' ;
  168.       point[x,    0] := '－' ;
  169.       point[x,-Vmax] := '－'
  170.     end ;
  171.  
  172.     pai2 := 2.0 * pai       ;      { 1円周(ラジアン) }
  173.     for x := 1 to Nissu[mp] do     { P(身体) S(感情) I(知性)について座標計算}
  174.     begin
  175.       point[x, round(sin(pai2*(day mod 23)/23) * Vmax)] := 'Ｐ' ; {23日周期}
  176.       point[x, round(sin(pai2*(day mod 28)/28) * Vmax)] := 'Ｓ' ; {28日周期}
  177.       point[x, round(sin(pai2*(day mod 33)/33) * Vmax)] := 'Ｉ' ; {33日周期}
  178.       day := day + 1
  179.     end ;
  180.  
  181.     Youbi(yb,mb,db,Ychar) ;        { 誕生日の曜日算出 }
  182.     page ;                         { 画面クリア       }
  183.     writeln(' ':Hbias,'*******',
  184.             ' バイオリズム (',yp:4,'年',mp:2,'月) P:身体 S:感情 I:知性 ',
  185.             '*******') ;
  186.     writeln(' ':Hbias+3,yb:4,'年',mb:2,'月',db:2,'日(',Ychar,')生まれ ',
  187.             '  1日現在の満生存日数は',LivingDay:5,'日') ;
  188.     writeln ;
  189.     write(' ':Hbias) ;
  190.     for x:=1 to Nissu[mp] do       { 日を出力 }
  191.       write(x:2) ;
  192.     writeln ;
  193.     write(' ':Hbias) ;
  194.     for x:=1 to Nissu[mp] do       { 曜日を出力 }
  195.     begin
  196.       Youbi(yp,mp,x,Ychar) ;
  197.       write(Ychar)
  198.     end ;
  199.     writeln ;
  200.     for y:=Vmax downto -Vmax do    { グラフを出力 }
  201.     begin
  202.       write(' ':Hbias) ;
  203.       for x:=1 to Nissu[mp] do
  204.         write(point[x,y]) ;
  205.       writeln
  206.     end
  207.  
  208.   end {Graph} ;
  209.  
  210. {****************************
  211.  *       メイン処理         *
  212.  ****************************}
  213. begin {main}
  214.   Init             ;               { 初期設定            }
  215.   InputInformation ;               { 誕生日､出力年月入力 }
  216.   Graph                            { グラフ作成&出力     }
  217. end.
  218.